Chip 2007 January, February, March & April/Chip-Cover-CD-2007-01.zip/01/Hity z okladki/Acronis True Image Home 10.0/ti_d_p_30.exe/AcronisTrueImage.msi/Binary.RegisterComPlusScript

Text File | 2006-11-28 | 18KB | 670 lines

'cscript for registering/unregistering Acronis VSS Provider

Option Explicit
Dim ProviderName, ProviderDLL, ProviderDescription
Dim Ok, OnRollback

Function VBScriptCA_RollbackUninst()
  Ok = 1
  OnRollback = 1
  WriteToLog "Args passed: "&Session.Property("CustomActionData")

  Dim Args
  Args = Split(Session.Property("CustomActionData"), ";")

  Dim Count, Dummy
  Count = 0
  WriteToLog "Parameters parsed:"
  For Each Dummy In Args
    Count = Count + 1
    WriteToLog "  "&Dummy
  Next

  If Count = 0 Then
    WriteToLog "No parameters were passed"
      VBScriptCA_RollbackUninst = 3
      Exit Function
  End If

  If Count > 0 Then
    If Args(0) = "-register" AND Count = 4 Then
      WriteToLog "Uninstall rollback mode detected.."
      ProviderName = Args(1)
      ProviderDLL = Args(2)
      ProviderDescription = Args(3)

      InstallClusterMSDTC

      If NOT Ok = 1 Then
        VBScriptCA_RollbackUninst = 1
        Exit Function
      End If

      InstallProvider

      Err = 0
    End If
  End If
  VBScriptCA_RollbackUninst = 1
  Exit Function
End Function

Function VBScriptCA_RollbackInst()
  Ok = 1
  OnRollback = 1
  WriteToLog "Args passed: "&Session.Property("CustomActionData")

  Dim Args
  Args = Split(Session.Property("CustomActionData"), ";")

  Dim Count, Dummy
  Count = 0
  WriteToLog "Parameters parsed:"
  For Each Dummy In Args
    Count = Count + 1
    WriteToLog "  "&Dummy
  Next

  If Count = 0 Then
    WriteToLog "No parameters were passed"
    VBScriptCA_RollbackInst = 1
    Exit Function
  End If

  If Count > 0 Then
    If Args(0) = "-unregister" AND Count = 3 Then
      WriteToLog "Rollback mode detected.."
      ProviderName = Args(1)
      ProviderDLL = Args(2)

      UninstallProvider

      If NOT Ok = 1 Then
      VBScriptCA_RollbackInst = Ok
      Exit Function
      End If

      Dim owsh
      Set owsh = CreateObject("Wscript.Shell")
      owsh.Run("regsvr32.exe /s /u "&ProviderDll)

      WriteToLog "Dll unregistered with error code = "&Err
      WriteToLog "Done."

    End If
  End If
  VBScriptCA_RollbackInst = 1
  Exit Function
End Function

Function VBScriptCA_Uninstall()
  Ok = 1
  OnRollback = 0
  WriteToLog "Args passed: "&Session.Property("CAUnRegisterComPLus_Acronis_VSS_Provider")

  Dim Args
  Args = Split(Session.Property("CAUnRegisterComPLus_Acronis_VSS_Provider"), ";")

  Dim Count, Dummy
  Count = 0
  WriteToLog "Parameters parsed:"
  For Each Dummy In Args
    Count = Count + 1
    WriteToLog "  "&Dummy
  Next

  If Count = 0 Then
    WriteToLog "No parameters were passed"
    VBScriptCA_Uninstall = 3
    Exit Function
  End If

  If Count > 0 Then
    If Args(0) = "-unregister" AND Count = 3 Then
      WriteToLog "Unregistering mode detected.."
      ProviderName = Args(1)
      ProviderDLL = Args(2)

      UninstallProvider

      If NOT Ok = 1 Then
        VBScriptCA_Uninstall = Ok
        Exit Function
      End If

      Dim owsh
      Set owsh = CreateObject("Wscript.Shell")
      owsh.Run("regsvr32.exe /s /u "&ProviderDll)

      WriteToLog "Dll unregistered with error code = "&Err
      WriteToLog "Done."
    End If
  End If

  VBScriptCA_Uninstall = 1
  Exit Function
End Function

Function VBScriptCA_Install()
  Ok = 1
  OnRollback = 0
  WriteToLog "Args passed: "&Session.Property("CustomActionData")

  Dim Args
  Args = Split(Session.Property("CustomActionData"), ";")

  Dim Count, Dummy
  Count = 0
  WriteToLog "Parameters parsed:"
  For Each Dummy In Args
    Count = Count + 1
    WriteToLog "  "&Dummy
  Next

  If Count = 0 Then
    WriteToLog "No parameters were passed"
      VBScriptCA_Install = 3
      Exit Function
  End If

  If Count > 0 Then
    If Args(0) = "-register" AND Count = 4 Then
      WriteToLog "Registering mode detected.."
      ProviderName = Args(1)
      ProviderDLL = Args(2)
      ProviderDescription = Args(3)

      InstallClusterMSDTC

      If NOT Ok = 1 Then
        VBScriptCA_Install = Ok
        Exit Function
      End If

      UninstallProvider

      If NOT Ok = 1 Then
        VBScriptCA_Install = Ok
        Exit Function
      End If

      Dim owsh
      Set owsh = CreateObject("Wscript.Shell")
      owsh.Run("regsvr32.exe /s /u "&ProviderDll)

      WriteToLog "Dll unregistered with error code = "&Err
      WriteToLog "Done."

      InstallProvider

      If NOT Ok = 1 Then
        VBScriptCA_Install = Ok
        Exit Function
      End If

    End If
  End If
  VBScriptCA_Install = 1
  Exit Function
End Function

'******************************************************************************
' WriteToLogs the usage
'******************************************************************************
Sub WriteToLogsUsage
  WriteToLog ""
  WriteToLog "Usage:"
  WriteToLog ""
  WriteToLog " 1) Registering a VSS/VDS Provider as a COM+ application:"
  WriteToLog "      CScript.exe " & Wscript.ScriptName & " -register <Provider_Name> <Provider.DLL>  <Provider_Description>"
  WriteToLog ""
  WriteToLog " 2) Unregistering a COM+ application associated with a VSS/VDS provider:"
  WriteToLog "      CScript.exe " & Wscript.ScriptName & " -unregister <Provider_Name>"
  WriteToLog ""
End Sub


'******************************************************************************
' Installs the Provider
'******************************************************************************
Sub InstallProvider
  On Error Resume Next

  WriteToLog "- Sleep for a second initially."
  Sleep 1000
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "Creating a new COM+ application:"
  WriteToLog "- Creating the catalog object "
  Dim cat
  Set cat = CreateObject("COMAdmin.COMAdminCatalog")
  CheckError 101
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Get the Applications collection"
  Dim collApps
  Set collApps = cat.GetCollection("Applications")
  CheckCollectionError 102, cat
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Populate..."
  collApps.Populate
  CheckCollectionError 103, collApps
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Add new application object"
  Dim app
  Set app = collApps.Add
  CheckCollectionError 104, collApps
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Set app name = " & ProviderName & " "
  app.Value("Name") = ProviderName
  CheckObjectError 105, collApps, app
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Set app description = " & ProviderDescription & " "
  app.Value("Description") = ProviderDescription
  CheckObjectError 106, collApps, app
  If NOT Ok = 1 Then Exit Sub

  ' Only roles added below are allowed to call in.
  WriteToLog "- Set app access check = true "
  app.Value("ApplicationAccessChecksEnabled") = 1
  CheckObjectError 107, collApps, app
  If NOT Ok = 1 Then Exit Sub

  ' Encrypting communication
  WriteToLog "- Set encrypted COM communication = true "
  app.Value("Authentication") = 6
  CheckObjectError 108, collApps, app
  If NOT Ok = 1 Then Exit Sub

  ' Secure references
  WriteToLog "- Set secure references = true "
  app.Value("AuthenticationCapability") = 2
  CheckObjectError 109, collApps, app
  If NOT Ok = 1 Then Exit Sub

  ' Do not allow impersonation
  WriteToLog "- Set impersonation = false "
  app.Value("ImpersonationLevel") = 2
  CheckObjectError 110, collApps, app
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Save changes..."
  collApps.SaveChanges
  CheckCollectionError 111, collApps
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Create Windows service running as Local System"
  cat.CreateServiceForApplication ProviderName, ProviderName , "SERVICE_AUTO_START", "SERVICE_ERROR_NORMAL", "", ".\localsystem", "", 0
  CheckCollectionError 112, cat
  If NOT Ok = 1 Then
    Ok = 1
    Err = 0
    WriteToLog "- Create Windows service failed."
    WriteToLog "- Sleep for 3 seconds then try again.."
    Sleep 3000
    If NOT Ok = 1 Then Exit Sub

    WriteToLog "- Create Windows service running as Local System"
    cat.CreateServiceForApplication ProviderName, ProviderName , "SERVICE_AUTO_START", "SERVICE_ERROR_NORMAL", "", ".\localsystem", "", 0
    CheckCollectionError 112, cat
  End If
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Add the DLL component"
  cat.InstallComponent ProviderName, ProviderDLL , "", ""
  CheckCollectionError 113, cat
  If NOT Ok = 1 Then Exit Sub
  WriteToLog "Done!"

  ' Add the new role for the Local SYSTEM account

  WriteToLog "Secure the COM+ application:"
  WriteToLog "- Get roles collection"
  Dim collRoles
  Set collRoles = collApps.GetCollection("Roles", app.Key)
  CheckCollectionError 120, cat
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Populate..."
  collRoles.Populate
  CheckCollectionError 121, collRoles
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Add new role"
  Dim role
  Set role = collRoles.Add
  CheckCollectionError 122, collRoles
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Set name = Administrators "
  role.Value("Name") = "Administrators"
  CheckObjectError 123, collRoles, role
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Set description = Administrators group "
  role.Value("Description") = "Administrators group"
  CheckObjectError 124, collRoles, role
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Save changes ..."
  collRoles.SaveChanges
  CheckCollectionError 125, collRoles
  If NOT Ok = 1 Then Exit Sub

  '
  ' Add users into role
  '

  WriteToLog "Granting user permissions:"
  Dim collUsersInRole
  Set collUsersInRole = collRoles.GetCollection("UsersInRole", role.Key)
  CheckCollectionError 130, collRoles
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Populate..."
  collUsersInRole.Populate
  CheckCollectionError 131, collUsersInRole
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Add new user"
  Dim user
  Set user = collUsersInRole.Add
  CheckCollectionError 132, collUsersInRole
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Searching for the Administrators account using WMI..."

  ' Get the Administrators account domain and name
  Dim strQuery
  strQuery = "select * from Win32_Account where SID='S-1-5-32-544' and localAccount=TRUE"
  Dim objSet
  set objSet = GetObject("winmgmts:").ExecQuery(strQuery)
  CheckError 133
  If NOT Ok = 1 Then Exit Sub

  Dim obj, Account
  For Each obj In objSet
    Set Account = obj
    Exit For
  Next

  WriteToLog "- Set user name = .\" & Account.Name & " "
  user.Value("User") = ".\" & Account.Name
  CheckObjectError 140, collUsersInRole, user
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Add new user"
  Set user = collUsersInRole.Add
  CheckCollectionError 141, collUsersInRole
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Set user name = Local SYSTEM "
  user.Value("User") = "SYSTEM"
  CheckObjectError 142, collUsersInRole, user
  If NOT Ok = 1 Then Exit Sub

  WriteToLog "- Save changes..."
  collUsersInRole.SaveChanges
  CheckCollectionError 143, collUsersInRole
  If NOT Ok = 1 Then Exit Sub

  Set app       = Nothing
  Set cat       = Nothing
  Set role      = Nothing
  Set user      = Nothing

  Set collApps  = Nothing
  Set collRoles = Nothing
  Set collUsersInRole = Nothing

  set objSet    = Nothing
  set obj       = Nothing

  WriteToLog "Done."

  On Error GoTo 0
End Sub


'******************************************************************************
' Uninstalls the Provider
'******************************************************************************
Sub UninstallProvider
  On Error Resume Next

  Dim cat
  Set cat = CreateObject("COMAdmin.COMAdminCatalog")
  CheckError 201
  If NOT Ok = 1 Then Exit Sub

  Dim collApps
  Set collApps = cat.GetCollection("Applications")
  CheckCollectionError 202, cat
  If NOT Ok = 1 Then Exit Sub

  collApps.Populate
  CheckCollectionError 203, collApps
  If NOT Ok = 1 Then Exit Sub

  Dim numApps
  numApps = collApps.Count
  Dim i
  For i = numApps - 1 To 0 Step -1
    If (StrComp(collApps.Item(i).Value("Name"), ProviderName) = 0) Then
      collApps.Remove(i)
      CheckCollectionError 204, collApps
      If NOT Ok = 1 Then Exit Sub
      WriteToLog "- Application " & ProviderName & " removed!"
    End If
  Next

  WriteToLog "- Saving changes..."
  collApps.SaveChanges
  CheckCollectionError 205, collApps
  If NOT Ok = 1 Then Exit Sub

  Set collApps = Nothing
  Set cat      = Nothing

  WriteToLog "Done."

  On Error GoTo 0
End Sub



'******************************************************************************
' Sub CheckError
'******************************************************************************
Sub CheckError(exitCode)
  If Err = 0 Then Exit Sub
  Ok = exitCode
  DumpVBScriptError exitCode
End Sub


'******************************************************************************
' Sub CheckCollectionError
'******************************************************************************
Sub CheckCollectionError(exitCode, coll)
  If Err = 0 Then Exit Sub
  Ok = exitCode
  DumpVBScriptError exitCode
  DumpComPlusError(coll.GetCollection("ErrorInfo"))
End Sub


'******************************************************************************
' Sub CheckObjectError
'******************************************************************************
Sub CheckObjectError(exitCode, coll, object)
  If Err = 0 Then Exit Sub
  Ok = exitCode
  DumpVBScriptError exitCode
  DumpComPlusError(coll.GetCollection("ErrorInfo"))
End Sub



'******************************************************************************
' Sub DumpVBScriptError
'******************************************************************************
Sub DumpVBScriptError(exitCode)
  WriteToLog vbNewLine & "ERROR:"
  WriteToLog "- Error code: " & Err & " [0x" & Hex(Err) & "]"
  WriteToLog "- Exit code: " & exitCode
  WriteToLog "- Description: " & Err.Description
  WriteToLog "- Source: " & Err.Source
  WriteToLog "- Help file: " & Err.Helpfile
  WriteToLog "- Help context: " & Err.HelpContext
End Sub


'******************************************************************************
' Sub DumpComPlusError
'******************************************************************************
Sub DumpComPlusError(errors)
  errors.Populate
  WriteToLog "- COM+ Errors detected: (" & errors.Count & ")"

  Dim error
  Dim I
  For I = 0 to errors.Count - 1
    Set error = errors.Item(I)
    WriteToLog "   * (COM+ ERROR " & I & ") on " & error.Value("Name")
    WriteToLog "       ErrorCode: " & error.Value("ErrorCode") & " [0x" & Hex(error.Value("ErrorCode")) & "]"
    WriteToLog "       MajorRef: " & error.Value("MajorRef")
    WriteToLog "       MinorRef: " & error.Value("MinorRef")
  Next
End Sub



'******************************************************************************
' Sub InstallClusterMSDTC
'******************************************************************************
Sub InstallClusterMSDTC
  On Error Resume Next

  Dim cluster, group, oMainGroup, oQuorumRes, oDTC, resource

  WriteToLog "Detecting MS Cluster..."

  Set cluster = CreateObject("MSCluster.Cluster")
  CheckError 400
  If Err <> 0 Then
    WriteToLog "- Unable to detect MS Cluster"
    Err = 0
    WriteToLog "- Proceeding with normal installation..."
    Ok = 1
    Exit Sub
  End If

  Call cluster.Open("")
  If Err <> 0 Then
    WriteToLog "- Cluster connection attempted. Exit code: " & Err & " [0x" & Hex(Err) & "]"
    Err = 0
    WriteToLog "- This is not a cluster node"
    WriteToLog "- Proceeding with normal installation..."
    Exit Sub
  End If

  WriteToLog "- Cluster node detected: " & cluster.Name

  ' If MS-DTC is already present, ignore
  For Each group In cluster.ResourceGroups
    For Each resource In group.Resources
      If resource.type.name = "Distributed Transaction Coordinator" Then
        WriteToLog "- An MS DTC resource is already present: " & resource.name
        Exit Sub
      End If
    Next
  Next

  ' Getting the quorum resource
  Set oQuorumRes = cluster.quorumresource
  CheckError 401

  ' Getting the main group
  Set oMainGroup = oQuorumRes.Group
  CheckError 402
  WriteToLog "- Adding new DTC resource in main group " & oMainGroup.Name

  ' Refresh the collection
  oMainGroup.resources.Refresh
  CheckError 405

  ' Creating the MS-DTC resource
  WriteToLog "- Creating the new DTC Resource..."
  Set oDTC = oMainGroup.Resources.CreateItem("DTC", "Distributed Transaction Coordinator", 0)
  CheckError 406

  WriteToLog "- Adding Network Name Dependancy..."
  for each resource in oMainGroup.resources
    if resource.type.name = "Network Name" then
      oDTC.dependencies.additem( resource)
      CheckError 407
      exit for
    end if
  next

  WriteToLog "- Adding Quorum Dependancy..."
  oDTC.dependencies.additem(oQuorumRes)
  CheckError 408

  WriteToLog "- Bringing MSDTC Online..."
  call oDTC.online("600")
  CheckError 409

  set oDTC = nothing
  set oMainGroup = nothing
  set resource = nothing
  set oQuorumRes = nothing
  set cluster = nothing

  On Error GoTo 0
End Sub

Sub WriteToLog(message)
  Const msiMessageTypeInfo = &H04000000
  Dim msg, record
  msg = "[CUSTOMACTION]: " + message
  Set record = Session.Installer.CreateRecord(1)
  record.StringData(1) = msg
  record.StringData(0) = "[1]"
  record.FormatText
  Session.Message msiMessageTypeInfo, record
End Sub

Sub Sleep(period)
  On Error Resume Next
  Ok = 1
  Dim wo
  Set wo = CreateObject("CASupp.ThreadWait")
  CheckError 1001

  If Err <> 0 Then
    WriteToLog "- Unable to create ActiveX object 'CASupp.ThreadWait'"
    Err = 0
    WriteToLog "- Continue immediately"
    Ok = 1
    Exit Sub
  End If

  wo.Wait(period)
  CheckError 1002

  If Err <> 0 Then
    WriteToLog "- ThreadWait failed"
    Err = 0
    WriteToLog "- Continue immediately"
    Ok = 1
    Exit Sub
  End If

End Sub